home *** CD-ROM | disk | FTP | other *** search
/ Delphi 2 - Developers' Solutions / Delphi 2 Developers' Solutions.iso / dds / chap02 / howto02 / drwsutl2.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-03-05  |  51.4 KB  |  1,397 lines

  1. unit Drwsutl2;
  2.  
  3. interface
  4.  
  5. uses
  6.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.   Forms, Dialogs, StdCtrls, Buttons, ExtCtrls, ShellAPI, FileCtrl, DRWSUtl1;
  8.  
  9. const
  10.   EOC_CHANGEDIR = 1;  { Error Operation Code for change directory failure }
  11.   EOC_SOURCECOPY = 2; { Error Operation Code for source copy failure      }
  12.   EOC_DESTCOPY = 3;   { Error Operation Code for destination copy failure }
  13.   EOC_DELETEFILE = 4; { Error Operation Code for file delete failure      }
  14.   EOC_DELETEDIR = 5;  { Error Operation Code for directory delete failure }
  15.   EOC_RENAMEFILE = 6; { Error Operation Code for renaming failure         }
  16.   EOC_MAKEDIR = 7;    { Error Operation Code for MkDir failure            }
  17.   EOC_SETATTR = 8;    { Error Operation Code for Set Attributes failure   }
  18.  
  19.   FAC_COPY = 1;       { File Action Code for recursive copying            }
  20.   FAC_MOVE = 2;       { File Action Code for recursive moving             }
  21.   FAC_DELETE = 3;     { File Action Code for recursive deletion           }
  22. type
  23.   TFileWorkBench = class( TComponent )
  24.   public
  25.     GlobalError        : Integer;  { This is used by FMXUCopyFile for er code }
  26.     GlobalErrorType    : Integer;  { This holds the Operation code            }
  27.     function ForceTrailingBackSlash( const TheFileName : String ) : String;
  28.     function StripNonRootTrailingBackSlash(
  29.               const TheFileName : String ) : String;
  30.     procedure GetFileAttributes( TheFile : String; var IsDirectory , IsArchive ,
  31.                 IsVolumeID , IsHidden , IsReadOnly , IsSysFile : Boolean );
  32.     procedure HandleIOException( TheOpCode : Integer; ThePath : String;
  33.                                  TheMessage : String; TheCode : Integer );
  34.     procedure HandleDOSError( TheOpCode : Integer; ThePath : String;
  35.                 TheCode : Integer );
  36.     procedure FMXUCopyFile(const FileName, DestName: String);
  37.     function CopyFile( TargetPath ,
  38.                DestinationPath : String ) : Boolean;
  39.     procedure ChangeTheDirectory( NewPath : String );
  40.     procedure ChangeTheDriveAndDirectory( NewDrive : Integer );
  41.     procedure CopyTheFile( OldPath , NewPath : String );
  42.     procedure MoveTheFile( OldPath , NewPath : String );
  43.     procedure DeleteTheFile( ThePath : String );
  44.     procedure RenameTheFile( OldPath , NewName : String );
  45.     procedure CreateNewDirectory( NewPath : String );
  46.     procedure RemoveDirectory( ThePath : String );
  47.   end;
  48.   TFileIconPanel = class( TPanel )
  49.   private
  50.     { Private declarations }
  51.     FHighlightColor : TColor;                 { This holds bright edge bevel }
  52.     FShadowColor    : TColor;                 { This holds dark edge bevel   }
  53.     procedure TheClick( Sender : TObject );   { This holds override click    }
  54.   protected                                   { event method procedure.      }
  55.     { Protected declarations }
  56.     procedure Paint; override;                { This allows custom painting  }
  57.   public
  58.     { Public declarations }
  59.     FTheIcon : TIcon;                         { This is the display icon    }
  60.     FTheName : String;                        { This is the filename        }
  61.     FTheLabel : TLabel;                       { This is the display label   }
  62.     Selected : Boolean;                       { This holds selection status }
  63.     constructor Create(AOwner : TComponent); override; { override create    }
  64.     procedure Initialize( PanelX              ,             { Left          }
  65.                           PanelY              ,             { Top           }
  66.                           PanelWidth          ,             { Width         }
  67.                           PanelHeight         ,             { Height        }
  68.                           PanelBevelWidth     ,             { Bevel Width   }
  69.                           LabelFontSize         : Integer;  { Font size     }
  70.                           PanelColor          ,             { Main color    }
  71.                           PanelHighlightColor ,             { Bright color  }
  72.                           PanelShadowColor    ,             { Dark color    }
  73.                           LabelTextColor        : TColor;   { Text color    }
  74.                           TheFilename         ,             { Filename      }
  75.                           LabelFontName         : String;   { Font name     }
  76.                           LabelFontStyle        : TFontStyles;  { Font style}
  77.                           ExtraData             : Integer       );  { Drive }
  78.     destructor Destroy; override;             { override destroy to free    }
  79.   end;
  80.   TFileIconPanelScrollBox = class( TScrollBox )
  81.   public
  82.     { Public methods and data }
  83.     TheFWB              : TFileWorkBench; { Used for file manipulation         }
  84.     IconsNeedRefreshing : Boolean;                   { Flag to redo display    }
  85.     TheIconSize        : Integer;   { Holds Individual Icon size               }
  86.     TheIconSpacing     : Integer;   { Holds total icon footprint               }
  87.     MaxIconsInARow     : Integer;   { Set for screen size.                     }
  88.     TheStoredHandle    : HWnd;
  89.     procedure Update;                                { Called to reset display }
  90.     constructor Create( AOwner : TComponent ); override;  { Override inherited }
  91.     procedure ClearTheFIPs;                          { Clears the FIPs safely  }
  92.     procedure AddDriveIcons( var XCounter , YCounter : Integer ); { Add drives }
  93.     procedure GetColorsForFileIcon( TheFile : String;
  94.                var BC , HC , SC , TC : TColor );
  95.     procedure GetIconsForEntireDirectory( TargetPath  : String );
  96.     function GetNextSelection( SourceDirectory : String;
  97.               var CurrentItem : Integer ) : String;
  98.   end;
  99.  
  100.   { This procedure gets an icon for a file using FindExecutable  }
  101.   { and ExtractIcon. (assumes file/dir is passed)                }
  102.   procedure GetIconForFile( TheName : String; var TheIcon : TIcon );
  103.   { This procedure spaces out the bitbtn components on a tpanel }
  104.   procedure SpacePanelButtons( WhichPanel : TPanel );
  105.  
  106. implementation
  107. {$R DRWSUTL2.RES}                 { Import custom resource file }
  108.  
  109. { This procedure spaces out the bitbtn components on a tpanel }
  110. procedure SpacePanelButtons( WhichPanel : TPanel );
  111. var TheCalculatedSpacing     ,            { Holds primary spacing }
  112.     TheFullCalculatedSpacing   : Integer; { Holds full spacing    }
  113.     Counter_1                  : Integer; { Loop counter          }
  114.     TotalIBs                   : Integer; { Gets total buttons    }
  115. begin
  116.   { Set up spacing values }
  117.   TotalIBs := WhichPanel.ControlCount;
  118.   TheCalculatedSpacing := (( WhichPanel.Width - 6 - ( TotalIbs * 49 ))
  119.    div ( TotalIbs + 1 ));
  120.   TheFullCalculatedSpacing := TheCalculatedSpacing + 49;
  121.   { Loop through all imported buttons and set their Left values }
  122.   for Counter_1 := 1 to WhichPanel.ControlCount do
  123.   begin
  124.     if Counter_1 = 1 then
  125.     begin
  126.       TBitBtn( WhichPanel.Controls[ Counter_1 - 1 ] ).Left := 3 +
  127.        TheCalculatedSpacing;
  128.     end
  129.     else
  130.     begin
  131.       TBitBtn( WhichPanel.Controls[ Counter_1 - 1 ] ).Left := 3 +
  132.        (( Counter_1 - 1 ) * TheFullCalculatedSpacing ) + TheCalculatedSpacing;
  133.     end;
  134.   end;
  135. end;
  136.  
  137. { This procedure gets an icon for a file using FindExecutable  }
  138. { and ExtractIcon. (assumes file/dir is passed)                }
  139. procedure GetIconForFile( TheName : String; var TheIcon : TIcon );
  140. var TheExt           : String; { File extension holder }
  141.     TheOtherPChar  ,           { Windows ASCIIZ string }
  142.     ThePChar         : PChar;  { Windows ASCIIZ string }
  143.     Dummy : Word;
  144. begin
  145.   { Check for directory and if so get directory icon from RES file }
  146.   if (( FileGetAttr( TheName ) and faDirectory ) = faDirectory ) then
  147.   begin
  148.     { Set up the PChar to communicate with Windows }
  149.     GetMem( TheOtherPChar , 255 );
  150.     { Convert Pascal-style string to ASCIIZ Pchar }
  151.     StrPCopy( TheOtherPChar , 'DIRECTORY' );
  152.     { Use API call to return icon handle of Icon Resource in FILECTRL.RES }
  153.     TheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  154.     { Release memory from PChar }
  155.     FreeMem( TheOtherPChar , 255 );
  156.     { Leave }
  157.     exit;
  158.   end;
  159.   { Assume archive file; get its extension }
  160.   TheExt := Uppercase( ExtractFileExt( TheName ));
  161.   { If not an executable/image file then use FindExecutable to get icon }
  162.   if (( TheExt <> '.EXE' ) and ( TheExt <> '.BAT' ) and
  163.       ( TheExt <> '.PIF' ) and ( TheExt <> '.COM' )) then
  164.   begin
  165.     { Grab three chunks of memory }
  166.     GetMem( ThePChar , 255 );
  167.     { Set up the name and its directory in Windows string formats }
  168.     StrPCopy( ThePChar, TheName );
  169.     Dummy := 65535;
  170.     {**** Windows 95 Specialized call ****** }
  171.     TheIcon.Handle := ExtractAssociatedIcon( hInstance , ThePChar , Dummy );
  172.     if TheIcon.Handle = 0 then
  173.     begin
  174.       GetMem( TheOtherPChar , 255 );
  175.       StrPCopy( TheOtherPChar , 'NOICON' );
  176.       TheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  177.       FreeMem( TheOtherPChar , 255 );
  178.       exit;
  179.     end;
  180.     FreeMem( ThePChar , 255 );
  181.   end
  182.   else
  183.   { Assume Windows Executable file, so get icon from it with ExtractIcon API }
  184.   begin
  185.     GetMem( ThePChar , 255 );
  186.     StrPCopy( ThePChar , TheName );
  187.     { Try to get first icon for file }
  188.     Dummy := 65535;
  189.     TheIcon.Handle := ExtractAssociatedIcon( hInstance , ThePChar , Dummy );
  190.     FreeMem( ThePChar , 255 );
  191.     { If handle is 0 invalid icon format so use default from RES file }
  192.     if TheIcon.Handle = 0 then
  193.     begin
  194.       GetMem( TheOtherPChar , 255 );
  195.       StrPCopy( TheOtherPChar , 'NOICON' );
  196.       TheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  197.       FreeMem( TheOtherPChar , 255 );
  198.       exit;
  199.     end;
  200.   end;
  201. end;
  202.  
  203. { This procedure does a fully error-trapped change directory }
  204. procedure TFileWorkBench.ChangeTheDirectory( NewPath : String );
  205. var CurrentDirectory : String;
  206. begin
  207.   if NewPath = '..' then
  208.   begin { Back up one level }
  209.     {$I+}
  210.     try
  211.       { Find the current directory }
  212.       GetDir( 0 , CurrentDirectory );
  213.       { Use EFP to move up one level }
  214.       CurrentDirectory := ExtractFilePath( CurrentDirectory );
  215.       { Strip trailing \ if not root }
  216.       CurrentDirectory := StripNonRootTrailingBackSlash( CurrentDirectory );
  217.       { Try the change to the new drive }
  218.       ChDir( CurrentDirectory );
  219.     except
  220.       { if any exception occurs instantiate exception and show }
  221.       On E:EInOutError do
  222.       begin
  223.         { Call custom error display/lookup procedure }
  224.         HandleIOException( EOC_CHANGEDIR , CurrentDirectory ,
  225.          E.Message , E.ErrorCode );
  226.       end;
  227.     end;
  228.   end
  229.   else
  230.   begin { Change to explicit path }
  231.     {$I+}
  232.     try
  233.       { Get target directory path }
  234.       CurrentDirectory := NewPath;
  235.       { Strip trailing \ if not root }
  236.       CurrentDirectory := StripNonRootTrailingBackSlash( CurrentDirectory );
  237.       { Try the change to the new drive }
  238.       ChDir( CurrentDirectory );
  239.     except
  240.       { if any exception occurs instantiate exception and show }
  241.       On E:EInOutError do
  242.       begin
  243.         { Call custom error display/lookup procedure }
  244.         HandleIOException( EOC_CHANGEDIR , CurrentDirectory ,
  245.          E.Message , E.ErrorCode );
  246.       end;
  247.     end;
  248.   end;
  249. end;
  250.  
  251. { This procedure does a fully error-trapped change directory }
  252. procedure TFileWorkBench.ChangeTheDriveAndDirectory( NewDrive : Integer );
  253. var CurrentDirectory : String;
  254. begin
  255.   {$I+}
  256.   try
  257.     { Find the working directory on new drive }
  258.     GetDir( NewDrive , CurrentDirectory );
  259.     { Try the change to the new drive }
  260.     ChDir( CurrentDirectory );
  261.   except
  262.     { if any exception occurs instantiate exception and show }
  263.     On E:EInOutError do
  264.     begin
  265.       { Call custom error display/lookup procedure }
  266.       HandleIOException( EOC_CHANGEDIR , CurrentDirectory ,
  267.        E.Message , E.ErrorCode );
  268.     end;
  269.   end;
  270. end;
  271.  
  272. { This procedure copies a single file with error trapping }
  273. procedure TFileWorkBench.CopyTheFile( OldPath , NewPath : String );
  274. var AResult : Boolean; { Internal data flag }
  275. begin
  276.   { If Copyfile returns false an error occurred }
  277.   AResult := CopyFile( OldPath , NewPath +
  278.    ExtractFileName( OldPath ));
  279.   { Display meaningful error message }
  280.   if not AResult then HandleDOSError( GlobalErrorType ,
  281.    ExtractFileName( OldPath ) , GlobalError );
  282. end;
  283.  
  284. { This procedure moves a file by copying and delete it }
  285. procedure TFileWorkBench.MoveTheFile( OldPath , NewPath : String );
  286. var AResult : Boolean; { Internal data flag }
  287.     TheFile : File;    { Use to get errors  }
  288. begin
  289.   { If Copyfile returns false an error occurred }
  290.   AResult := CopyFile( OldPath , NewPath +
  291.     ExtractFileName( OldPath ));
  292.   { Display meaningful error message }
  293.   if not AResult then HandleDOSError( GlobalErrorType ,
  294.    ExtractFileName( OldPath ), GlobalError );
  295.   { After valid copying, delete source file }
  296.   {$I+}
  297.   if AResult then try
  298.     { Use this trick to get valid exception handling }
  299.     AssignFile( TheFile , OldPath );
  300.     { Use erase because Deletefile doesn't give exceptions! }
  301.     Erase( TheFile );
  302.   except
  303.     { if any exception occurs instantiate exception and show }
  304.     On E:EInOutError do
  305.     begin
  306.       { Call custom error display/lookup procedure }
  307.       HandleIOException( EOC_DELETEFILE , ExtractFileName( OldPath ) ,
  308.        E.Message , E.ErrorCode );
  309.     end;
  310.   end;
  311. end;
  312.  
  313. { This procedure safely deletes a single file }
  314. procedure TFileWorkBench.DeleteTheFile( ThePath : String );
  315. var TheFile : File; { Internal file handle }
  316. begin
  317.   {$I+}
  318.   try
  319.     { Use this trick to get valid exception handling }
  320.     AssignFile( TheFile , ThePath );
  321.     { Use erase because Deletefile doesn't give exceptions! }
  322.     Erase( TheFile );
  323.   except
  324.     { if any exception occurs instantiate exception and show }
  325.     On E:EInOutError do
  326.     begin
  327.       { Call custom error display/lookup procedure }
  328.       HandleIOException( EOC_DELETEFILE , ExtractFileName( ThePath ) ,
  329.        E.Message , E.ErrorCode );
  330.     end;
  331.   end;
  332. end;
  333.  
  334. { This procedure renames a file with full error trapping }
  335. procedure TFileWorkBench.RenameTheFile( OldPath , NewName : String );
  336. var TheFile : File; { Internal file handle }
  337. begin
  338.   {$I+}
  339.   try
  340.     { Use this trick to get valid exception handling }
  341.     AssignFile( TheFile , OldPath );
  342.     { Use this because RenameFile doesn't give exceptions! }
  343.     Rename( TheFile , NewName );
  344.   except
  345.     { if any exception occurs instantiate exception and show }
  346.     On E:EInOutError do
  347.     begin
  348.       { Call custom error display/lookup procedure }
  349.       HandleIOException( EOC_RENAMEFILE , ExtractFileName( OldPath ) ,
  350.        E.Message , E.ErrorCode );
  351.     end;
  352.   end;
  353. end;
  354.  
  355. { This procedure creates a new directory with full error trapping }
  356. procedure TFileWorkBench.CreateNewDirectory( NewPath : String );
  357. begin
  358.   {$I+}
  359.   try
  360.     Mkdir( NewPath );
  361.   except
  362.     { if any exception occurs instantiate exception and show }
  363.     On E:EInOutError do
  364.     begin
  365.       { Call custom error display/lookup procedure }
  366.       HandleIOException( EOC_MAKEDIR , ExtractFileName( NewPath ) ,
  367.        E.Message , E.ErrorCode );
  368.     end;
  369.   end;
  370. end;
  371.  
  372. { This procedure remove a directory with full error trapping }
  373. procedure TFileWorkBench.RemoveDirectory( ThePath : String );
  374. begin
  375.   {$I+}
  376.   try
  377.     Rmdir( ThePath );
  378.   except
  379.     { if any exception occurs instantiate exception and show }
  380.     On E:EInOutError do
  381.     begin
  382.       { Call custom error display/lookup procedure }
  383.       HandleIOException( EOC_DELETEDIR , ExtractFileName( ThePath ) ,
  384.        E.Message , E.ErrorCode );
  385.     end;
  386.   end;
  387. end;
  388.  
  389. { This is a generic copy routine taken from Delphi sample code }
  390. { It has been edited to return viable error codes!             }
  391. procedure TFileWorkBench.FMXUCopyFile(const FileName, DestName: String);
  392. var
  393.   CopyBuffer: Pointer; { buffer for copying }
  394.   BytesCopied: Longint;
  395.   TheAttr : Integer;
  396.   Source, Dest: Integer; { handles }
  397. const
  398.   ChunkSize: Longint = 8192; { copy in 8K chunks }
  399. begin
  400.   GetMem(CopyBuffer, ChunkSize); { allocate the buffer }
  401.   Source := FileOpen(FileName, fmShareDenyWrite); { open source file }
  402.   if Source < 0 then
  403.   begin  { error creating source file }
  404.     GlobalErrorType := EOC_SOURCECOPY;
  405.     GlobalError := -IOResult;
  406.     if GlobalError = 0 then GlobalError := -157;
  407.     FreeMem( CopyBuffer, ChunkSize );
  408.     exit;
  409.   end;
  410.   Dest := FileCreate(DestName); { create output file; overwrite existing }
  411.   if Dest < 0 then
  412.   begin  { error creating destination file }
  413.     FileClose( Source );
  414.     GlobalErrorType := EOC_DESTCOPY;
  415.     GlobalError := -IOResult;
  416.     if GlobalError = 0 then GlobalError := -159;
  417.     FreeMem( CopyBuffer , ChunkSize );
  418.     exit;
  419.   end;
  420.   {$I-}
  421.   repeat
  422.     BytesCopied := FileRead(Source, CopyBuffer^, ChunkSize); { read chunk}
  423.     if BytesCopied > 0 then { if we read anything... }
  424.     FileWrite(Dest, CopyBuffer^, BytesCopied); { ...write chunk }
  425.   until BytesCopied < ChunkSize; { until we run out of chunks }
  426.   {$I+}
  427.   GlobalError := -IOResult;  { get any error code which happens during copying }
  428.   FileClose(Dest); { close the destination file }
  429.   FileClose(Source); { close the source file }
  430.   FreeMem(CopyBuffer, ChunkSize); { free the buffer }
  431. end;
  432.  
  433. { This function calls the sample Copy code and handles errors }
  434. function TFileWorkBench.CopyFile( TargetPath ,
  435.           DestinationPath : String ) : Boolean;
  436. begin
  437.   { Set global error value to no error }
  438.   GlobalError := 0;
  439.   { Call the sample procedure to do the copy }
  440.   FMXUCopyFile( TargetPath, DestinationPath );
  441.   { If no error return true else return false }
  442.   if GlobalError < 0 then CopyFile := false else
  443.    CopyFile := true;
  444. end;
  445.  
  446. { This procedure handles displaying a user-friendly Dialog box with a }
  447. { Message for Delphi IO exception errors.                             }
  448. procedure TFileWorkBench.HandleIOException( TheOpCode : Integer;
  449.            ThePath : String; TheMessage : String; TheCode : Integer );
  450. var ErrorMessageString : String;  { Holds internal data }
  451.     OperationString    : String;  { Holds internal data }
  452. begin
  453.   { clear to check for unrecognized code }
  454.   ErrorMessageString := '';
  455.   { Check against imported code }
  456.   case TheCode of
  457.     2    : ErrorMessageString := 'File not found';
  458.     3    : ErrorMessageString := 'Path not found';
  459.     4    : ErrorMessageString := 'Too many open files';
  460.     5    : ErrorMessageString := 'File access denied';
  461.     6    : ErrorMessageString := 'Invalid file handle';
  462.     12    : ErrorMessageString := 'Invalid file access code';
  463.     15    : ErrorMessageString := 'Invalid drive number';
  464.     16  : ErrorMessageString := 'Cannot remove current directory';
  465.     17    : ErrorMessageString := 'Cannot rename across drives';
  466.     100    : ErrorMessageString := 'Disk read error';
  467.     101    : ErrorMessageString := 'Disk write error';
  468.     102    : ErrorMessageString := 'File not assigned';
  469.     103    : ErrorMessageString := 'File not open';
  470.     104    : ErrorMessageString := 'File not open for input';
  471.     105    : ErrorMessageString := 'File not open for output';
  472.   end;
  473.   case TheOpCode of
  474.     EOC_CHANGEDIR : OperationString := 'Unable to Change Directory due to ';
  475.     EOC_SOURCECOPY : OperationString := 'Unable to Copy due to Source File ';
  476.     EOC_DESTCOPY : OperationString := 'Unable to Copy due to Destination File ';
  477.     EOC_DELETEFILE : OperationString := 'Unable to Delete File due to ';
  478.     EOC_DELETEDIR : OperationString := 'Unable to Delete Directory due to ';
  479.     EOC_RENAMEFILE : OperationString := 'Unable to Rename File due to ';
  480.     EOC_MAKEDIR : OperationString := 'Unable to Create New Directory due to ';
  481.     EOC_SETATTR : OperationString := 'Unable to Set File Attributes due to ';
  482.   end;
  483.   { If not recognized use message; not a DOS error; reset cursor for neatness }
  484.   if ErrorMessageString = '' then
  485.   begin
  486.     Screen.Cursor := crDefault;
  487.     MessageDlg( OperationString + ExtractFileName( ThePath ) + ' ' +
  488.      TheMessage , mtError , [mbOK],0);
  489.   end
  490.   else
  491.   begin
  492.     { Recognized DOS exception, reset cursor for neatness }
  493.     Screen.Cursor := crDefault;
  494.     MessageDlg( OperationString + ExtractFileName( ThePath ) + ' ' +
  495.      ErrorMessageString , mtError , [mbOK], 0 );
  496.   end;
  497. end;
  498.  
  499. { This procedure handles displaying a user-friendly Dialog box with a }
  500. { Message for DOS error codes.                                        }
  501. procedure TFileWorkBench.HandleDOSError( TheOpCode : Integer;
  502.            ThePath : String;  TheCode : Integer );
  503. var ErrorMessageString : String;  { internal message holder }
  504.     OperationString : String;     { internal message holder }
  505. begin
  506.   { clear the message holder to check for unrecognized code }
  507.   ErrorMessageString := '';
  508.   { Negate the code back to normal number and check to set string }
  509.   case -TheCode of
  510.     2    : ErrorMessageString := 'File not found';
  511.     3    : ErrorMessageString := 'Path not found';
  512.     4    : ErrorMessageString := 'Too many open files';
  513.     5    : ErrorMessageString := 'File access denied';
  514.     6    : ErrorMessageString := 'Invalid file handle';
  515.     12    : ErrorMessageString := 'Invalid file access code';
  516.     15    : ErrorMessageString := 'Invalid drive number';
  517.     16  : ErrorMessageString := 'Cannot remove current directory';
  518.     17    : ErrorMessageString := 'Cannot rename across drives';
  519.     100    : ErrorMessageString := 'Disk read error';
  520.     101    : ErrorMessageString := 'Disk write error';
  521.     102    : ErrorMessageString := 'File not assigned';
  522.     103    : ErrorMessageString := 'File not open';
  523.     104    : ErrorMessageString := 'File not open for input';
  524.     105    : ErrorMessageString := 'File not open for output';
  525.     157 : ErrormessageString := 'Could not open Source File';
  526.     159 : ErrormessageString := 'Could not open Target File';
  527.   end;
  528.   case TheOpCode of
  529.     EOC_CHANGEDIR : OperationString := 'Unable to Change Directory due to ';
  530.     EOC_SOURCECOPY : OperationString := 'Unable to Copy due to Source File ';
  531.     EOC_DESTCOPY : OperationString := 'Unable to Copy due to Destination File ';
  532.     EOC_DELETEFILE : OperationString := 'Unable to Delete File due to ';
  533.     EOC_DELETEDIR : OperationString := 'Unable to Delete Directory due to ';
  534.     EOC_RENAMEFILE : OperationString := 'Unable to Rename File due to ';
  535.     EOC_MAKEDIR : OperationString := 'Unable to Create New Directory due to ';
  536.     EOC_SETATTR : OperationString := 'Unable to Set File Attributes due to ';
  537.   end;
  538.   { If the string is empty an unrecognized code was sent in }
  539.   if ErrorMessageString = '' then
  540.   begin
  541.     { Sent up db based on source or target error; reset cursor for neatness }
  542.     Screen.Cursor := crDefault;
  543.     MessageDlg( OperationString + ExtractFileName( ThePath ) + ' Error Code: ' +
  544.      IntToStr( TheCode ) , mtError , [mbOK],0);
  545.   end
  546.   else  { Code is recognized, use message from case statement }
  547.   begin
  548.     { Format the output for source or target error }
  549.     Screen.Cursor := crDefault;
  550.     MessageDlg( OperationString + ExtractFilePath( ThePath ) + ' ' +
  551.      ErrorMessageString , mtError , [mbOK], 0 );
  552.   end;
  553. end;
  554.  
  555. { This procedure sets the imported booleans to the file's attributes }
  556. procedure TFileWorkBench.GetFileAttributes( TheFile : String; var IsDirectory ,
  557.            IsArchive , IsVolumeID , IsHidden , IsReadOnly ,
  558.             IsSysFile : Boolean );
  559. var TheResult : Integer; { Traps for error code on VolumeID }
  560. begin
  561.   { Clear the imported flags for default }
  562.   IsDirectory := false;
  563.   IsArchive := false;
  564.   IsVolumeID := false;
  565.   IsHidden := False;
  566.   IsReadOnly := false;
  567.   IsSysFile := false;
  568.   { Make the Dos call }
  569.   TheResult := FileGetAttr( TheFile );
  570.   if TheResult < 0 then
  571.   begin
  572.     { Volume ID returns -2 (?) }
  573.     IsVolumeID := true;
  574.     { It has no other properties }
  575.     exit;
  576.   end;
  577.   { Use AND test to set all other properties }
  578.   if (( TheResult and faDirectory ) = faDirectory ) then IsDirectory := true;
  579.   if (( TheResult and faArchive ) = faArchive ) then IsArchive := true;
  580.   if (( TheResult and faVolumeID ) = faVolumeID ) then IsVolumeID := true;
  581.   if (( TheResult and faReadOnly ) = faReadOnly ) then IsReadOnly := true;
  582.   if (( TheResult and faHidden ) = faHidden ) then IsHidden := true;
  583.   if (( TheResult and faSysFile ) = faSysFile ) then IsSysFile := true;
  584. end;
  585.  
  586. { This function makes sure a pathname has a trailing \ }
  587. function TFileWorkBench.ForceTrailingBackSlash(
  588.           const TheFileName : String ) : String;
  589. var TempString : String;  { Used to hold function result }
  590. begin
  591.   { If no trailing \ add one (root will already have one.) }
  592.   if TheFileName[ Length( TheFileName ) ] <> '\' then
  593.    TempString := TheFileName + '\' else TempString := TheFileName;
  594.   { Return modified or non-modified string }
  595.   ForceTrailingBackslash := TempString;
  596. end;
  597.  
  598. { This function makes sure a non-root dir has no trailing \ }
  599. function TFileWorkBench.StripNonRootTrailingBackSlash(
  600.           const TheFileName : String ) : String;
  601. var TempString : String ; { Used to hold function result }
  602. begin
  603.   { Default is no change }
  604.   TempString := TheFileName;
  605.   { If not root then }
  606.   if Length( TheFileName ) > 3 then
  607.   begin
  608.     { If has a trailing backslash remove it }
  609.     if TheFileName[ Length( TheFileName )] = '\' then
  610.     begin
  611.       TempString := Copy( TheFileName , 1 ,
  612.        Length( TheFileName ) - 1 );
  613.     end;
  614.   end;
  615.   { Export the final result }
  616.   StripNonRootTrailingBackSlash := TempString;
  617. end;
  618.  
  619. { Create method for FIP                                }
  620. constructor TFileIconPanel.Create( AOwner : TComponent );
  621. begin
  622.   { call inherited -- VITAL! }
  623.   inherited Create( AOwner );
  624.   { create icon and label components, making self owner/displayer }
  625.   FTheIcon := TIcon.Create;
  626.   FTheLabel := TLabel.Create( Self );
  627.   FThelabel.Parent := Self;
  628.   { Set own and labels mouse methods to stored methods }
  629.   OnClick := TheClick;
  630.   FTheLabel.OnClick := TheClick;
  631.   { Set alignment and autosize properties of the label }
  632.   FTheLabel.Autosize := false;
  633.   FTheLabel.Alignment := taCenter;
  634.   { Set selected to false }
  635.   Selected := false;
  636. end;
  637.  
  638. { Initialization method for FIP                                         }
  639. procedure TFileIconPanel.Initialize( PanelX              ,
  640.                                      PanelY              ,
  641.                                      PanelWidth          ,
  642.                                      PanelHeight         ,
  643.                                      PanelBevelWidth     ,
  644.                                      LabelFontSize         : Integer;
  645.                                      PanelColor          ,
  646.                                      PanelHighlightColor ,
  647.                                      PanelShadowColor    ,
  648.                                      LabelTextColor        : TColor;
  649.                                      TheFilename         ,
  650.                                      LabelFontName         : String;
  651.                                      LabelFontStyle        : TFontStyles;
  652.                                      ExtraData             : Integer );
  653.  
  654. var TheLabelHeight ,             { Holder for label pixel height }
  655.     TheLabelWidth    : Integer;  { Holder for label pixel width  }
  656.     TheOtherPChar    : PChar;    { Windows ASCIIZ string         }
  657. begin
  658.   { Set the basic properties based on imported parameters }
  659.   Left := PanelX;
  660.   Top := PanelY;
  661.   Width := PanelWidth;
  662.   Height := PanelHeight;
  663.   Color := PanelColor;
  664.   BevelWidth := PanelBevelWidth;
  665.   FHighlightColor := PanelHighlightColor;
  666.   FShadowColor := PanelShadowColor;
  667.   FTheName := TheFilename;
  668.   { If the ExtraData field is non-0 then a drive is being sent in }
  669.   if ExtraData <> 0 then
  670.   begin
  671.     { Use the data field value to determine which icon to get from RES file }
  672.     case ExtraData of
  673.       1 : begin
  674.             GetMem( TheOtherPChar , 255 );
  675.             StrPCopy( TheOtherPChar , 'FLOPPY35' );
  676.             FTheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  677.             FreeMem( TheOtherPChar , 255 );
  678.           end;
  679.       2 : begin
  680.             GetMem( TheOtherPChar , 255 );
  681.             StrPCopy( TheOtherPChar , 'FIXEDHD' );
  682.             FTheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  683.             FreeMem( TheOtherPChar , 255 );
  684.           end;
  685.       3 : begin
  686.             GetMem( TheOtherPChar , 255 );
  687.             StrPCopy( TheOtherPChar , 'NETWORKHD' );
  688.             FTheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  689.             FreeMem( TheOtherPChar , 255 );
  690.           end;
  691.       4 : begin
  692.             GetMem( TheOtherPChar , 255 );
  693.             StrPCopy( TheOtherPChar , 'CDROM' );
  694.             FTheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  695.             FreeMem( TheOtherPChar , 255 );
  696.           end;
  697.       5 : begin
  698.             GetMem( TheOtherPChar , 255 );
  699.             StrPCopy( TheOtherPChar , 'RAM' );
  700.             FTheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  701.             FreeMem( TheOtherPChar , 255 );
  702.           end;
  703.     end;
  704.     { The FileNme property is already set up for the caption; use directly }
  705.     FTheLabel.Caption := TheFilename;
  706.     { Set up the hint for later use (make sure to set ShowHint) }
  707.     Hint := 'Change to ' + TheFileName;
  708.     ShowHint := true;
  709.     { Set up all imported label properties and center it for drawing }
  710.     with FTheLabel do
  711.     begin
  712.       Font.Name := LabelFontName;
  713.       Font.Size := LabelFontSize;
  714.       Font.Style := LabelFontStyle;
  715.       Font.Color := LabelTextColor;
  716.       Canvas.Brush.Color := PanelColor;
  717.       Canvas.Font := Font;
  718.       TheLabelHeight := Canvas.Textheight( Caption ) + 4;
  719.       TheLabelWidth := Canvas.Textwidth( Caption ) + 4;
  720.       Left := (( Self.Width - TheLabelWidth ) div 2 ) + 1;
  721.       Top := ((( Round( Self.Height * 0.25 ) - 6 ) - TheLabelHeight) div 2) + 1;
  722.       Top := Top + Round( Self.Height * 0.75 );
  723.       Height := TheLabelHeight;
  724.       Width := TheLabelWidth;
  725.     end;
  726.   end
  727.   else
  728.   begin
  729.     { A file or directory has been sent in; use GetIconForFile to obtain an }
  730.     { icon either from the file, its owner, or a RES file default.          }
  731.     GetIconForFile( FTheName , FTheIcon );
  732.     { Check for the Backup caption and set it specially }
  733.     if ExtractfileName( FThename ) = '..' then
  734.     begin
  735.       FTheLabel.Caption := '..';
  736.       Hint := 'Up One Level';
  737.     end
  738.     else
  739.     begin
  740.       { Otherwise just get the filename for the label caption }
  741.       { And the full path for the hint (used later.)          }
  742.       FTheLabel.caption := ExtractFileName( UpperCase( FTheName ));
  743.       Hint := FTheName;
  744.     end;
  745.     { Activate showhint so hints are seen }
  746.     ShowHint := true;
  747.     { Set label properties with imported values and center for display }
  748.     with FTheLabel do
  749.     begin
  750.       Font.Name := LabelFontName;
  751.       Font.Size := LabelFontSize;
  752.       Font.Style := LabelFontStyle;
  753.       Font.Color := LabelTextColor;
  754.       Canvas.Brush.Color := PanelColor;
  755.       Canvas.Font := Font;
  756.       TheLabelHeight := Canvas.Textheight( Caption ) + 4;
  757.       TheLabelWidth := Canvas.Textwidth( Caption ) + 4;
  758.       Left := (( Self.Width - TheLabelWidth ) div 2 ) + 1;
  759.       Top := ((( Round( Self.Height * 0.25 ) - 6 ) - TheLabelHeight) div 2) + 1;
  760.       Top := Top + Round( Self.Height * 0.75 );
  761.       Height := TheLabelHeight;
  762.       Width := TheLabelWidth;
  763.     end;
  764.   end;
  765. end;
  766.  
  767. { Destroy method for FIP }
  768. destructor TFileIconPanel.Destroy;
  769. begin
  770.   { free component resources }
  771.   FTheIcon.Free;
  772.   FTheLabel.Free;
  773.   { call inherited -- VITAL! }
  774.   inherited Destroy;
  775. end;
  776.  
  777. { TheClick method for FIP; used for event responses }
  778. procedure TFileIconPanel.TheClick( Sender : TObject );
  779. begin
  780.   { Currently ignore drive clicks }
  781.   if Pos( 'DRIVE' , FTheName ) > 0 then exit;
  782.   { Flip status of bevels }
  783.   if BevelOuter = bvRaised then BevelOuter := bvLowered else
  784.    BevelOuter := bvRaised;
  785.   { Flip selected variable }
  786.   Selected := not Selected;
  787.   { Set redisplay }
  788.   Invalidate;
  789. end;
  790.  
  791. { Paint method for FIP; overrides normal paint }
  792. procedure TFileIconPanel.Paint;
  793. var
  794.   TheOtherRect   : TRect;   { Holds clientrect   }
  795.   TopColor     ,            { Holds bright color }
  796.   BottomColor    : TColor;  { Holds dark color   }
  797.  
  798. { These methods are from Borland Intl., copyright 1995 }
  799. procedure Frame3D(    Canvas       : TCanvas;
  800.                   var TheRect      : TRect;
  801.                       TopColor   ,
  802.                       BottomColor  : TColor;
  803.                       Width        : Integer );
  804.  
  805. procedure DoRect;
  806. var
  807.   TopRight, BottomLeft: TPoint;
  808. begin
  809.   with Canvas, TheRect do
  810.   begin
  811.     TopRight.X := Right;
  812.     TopRight.Y := Top;
  813.     BottomLeft.X := Left;
  814.     BottomLeft.Y := Bottom;
  815.     Pen.Color := TopColor;
  816.     PolyLine([BottomLeft, TopLeft, TopRight]);
  817.     Pen.Color := BottomColor;
  818.     Dec(BottomLeft.X);
  819.     PolyLine([TopRight, BottomRight, BottomLeft]);
  820.   end;
  821. end;
  822.  
  823. begin
  824.   Canvas.Pen.Width := 1;
  825.   Dec(TheRect.Bottom); Dec(TheRect.Right);
  826.   while Width > 0 do
  827.   begin
  828.     Dec(Width);
  829.     DoRect;
  830.     InflateRect(TheRect, -1, -1);
  831.   end;
  832.   Inc(TheRect.Bottom); Inc(TheRect.Right);
  833. end;
  834.  
  835. procedure AdjustColors(Bevel: TPanelBevel);
  836. begin
  837.   TopColor := FHighlightColor;
  838.   if Bevel = bvLowered then TopColor := FShadowColor;
  839.   BottomColor := FShadowColor;
  840.   if Bevel = bvLowered then BottomColor := FHighlightColor;
  841. end;
  842.  
  843. { Custom code begins here }
  844. begin
  845.   { Get the rectangle of the control with API/method call }
  846.   TheOtherRect := GetClientRect;
  847.   { draw basic rectangle with basic color }
  848.   with Canvas do
  849.   begin
  850.     Brush.Color := Color;
  851.     FillRect(TheOtherRect);
  852.   end;
  853.   { Set up for top "icon" frame  and draw it with frame3d }
  854.   TheOtherRect.Right := Width;
  855.   TheOtherRect.Bottom := Round( Height * 0.75 ) - 6 ;
  856.   if BevelOuter <> bvNone then
  857.   begin
  858.     AdjustColors(BevelOuter);
  859.     Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  860.   end;
  861.   Frame3D(Canvas, TheOtherRect, Color, Color, BorderWidth);
  862.   if BevelInner <> bvNone then
  863.   begin
  864.     AdjustColors(BevelInner);
  865.     Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  866.   end;
  867.   { Do the same for the lower "label" frame }
  868.   TheOtherRect.Top := Round( Height * 0.75 ) - 5;
  869.   TheOtherRect.Left := 0;
  870.   TheOtherRect.Bottom := Height;
  871.   TheOtherRect.Right := Width;
  872.   if BevelOuter <> bvNone then
  873.   begin
  874.     AdjustColors(BevelOuter);
  875.     Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  876.   end;
  877.   Frame3D(Canvas, TheOtherRect, Color, Color, BorderWidth);
  878.   if BevelInner <> bvNone then
  879.   begin
  880.     AdjustColors(BevelInner);
  881.     Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  882.   end;
  883.   { Then draw the icon using canvas draw method }
  884.   Canvas.Draw( (( Width - 32 ) div 2 ) + 1 ,
  885.   ((( Round( Height * 0.75 ) - 6 ) - 32 ) div 2 ) + 1 , FTheIcon );
  886. end;
  887.  
  888. { This procedure clears a scrollbox of all FileIconPanels }
  889. procedure TFileIconPanelScrollbox.ClearTheFIPs;
  890. var Counter_1 : Integer;
  891.     TheComponent : TComponent;
  892. begin
  893.   { Note that must use while loop since component count continually }
  894.   { decreases as removes are made!                                  }
  895.   while ComponentCount > 0 do
  896.   begin
  897.     { Save the component as a generic TComponent }
  898.     TheComponent := Components[ 0 ];
  899.     { Call removecomponent to pull it out of the owner list for sb }
  900.     { This avoids GPF when freeing the sb.                         }
  901.     RemoveComponent( Components[ 0 ]);
  902.     { Typecast the pointer and free it to release memory and res. }
  903.     TFileIconPanel( TheComponent ).Free;
  904.   end;
  905. end;
  906.  
  907. { This procedure scans for drives and obtains their type and creates file }
  908. { icon panels to represent them.                                          }
  909. procedure TFileIconPanelScrollBox.AddDriveIcons( var XCounter ,
  910.            YCounter : Integer );
  911. type
  912.   { This if from filectrl unit; reproduce here for completeness }
  913.   TDriveType = (dtUnknown, dtNoDrive, dtFloppy, dtFixed, dtNetwork, dtCDROM,
  914.                 dtRAM);
  915. var
  916.   DrivePC         : array[0..256] of char;
  917.   DriveNum        : Integer;         { Used to get next drive via DOS fn   }
  918.   IconType        : Integer;         { Used to hold icon type (defacto dt) }
  919.   DriveChar       : Char;            { Used to hold drive letter           }
  920.   DriveType       : TDriveType;      { Used for set-valued drive type      }
  921.   Finished        : Boolean;         { Loop flag                           }
  922.   TheFIP          : TFileIconPanel;  { Generic FileIconPanel variable      }
  923.   ButtonColor   ,                    { Main panel color                    }
  924.   ButtonHLColor ,                    { Bright panel color                  }
  925.   ButtonSColor  ,                    { Dark panel color                    }
  926.   Textcolor       : TColor;          { Label text color                    }
  927.  
  928. (*{ This code is from the FileCtrl Unit; copyright Borland Intl 1995      }
  929. { Check whether drive is a CD-ROM.  Returns True if MSCDEX is installed }
  930. {  and the drive is using a CD driver                                   }
  931.  
  932. function IsCDROM(DriveNum: Integer): Boolean; assembler;
  933. asm
  934.   MOV   AX,1500h { look for MSCDEX }
  935.   XOR   BX,BX
  936.   INT   2fh
  937.   OR    BX,BX
  938.   JZ    @Finish
  939.   MOV   AX,150Bh { check for using CD driver }
  940.   MOV   CX,DriveNum
  941.   INT   2fh
  942.   OR    AX,AX
  943.   @Finish:
  944. end;
  945.  
  946. { This code is from the FileCtrl Unit; copyright Borland Intl 1995      }
  947. { Check whether drive is a RAM drive.                                   }
  948. function IsRAMDrive(DriveNum: Integer): Boolean; assembler;
  949. var
  950.   TempResult: Boolean;
  951. asm
  952.   MOV   TempResult,False
  953.   PUSH  DS
  954.   MOV   BX,SS
  955.   MOV   DS,BX
  956.   SUB   SP,0200h
  957.   MOV   BX,SP
  958.   MOV   AX,DriveNum
  959.   MOV   CX,1
  960.   XOR   DX,DX
  961.   INT   25h  { read boot sector }
  962.   ADD   SP,2
  963.   JC    @ItsNot
  964.   MOV   BX,SP
  965.   CMP   BYTE PTR SS:[BX+15h],0F8h  { reverify fixed disk }
  966.   JNE   @ItsNot
  967.   CMP   BYTE PTR SS:[BX+10h],1  { check for single FAT }
  968.   JNE   @ItsNot
  969.   MOV   TempResult,True
  970.   @ItsNot:
  971.   ADD   SP,0200h
  972.   POP   DS
  973.   MOV   AL, TempResult
  974. end;
  975.  
  976. { This code is from the FileCtrl Unit; copyright Borland Intl 1995      }
  977. { Finds the type of a drive letter.                                     }
  978. function FindDriveType(DriveNum: Integer): TDriveType;
  979. begin
  980.   Result := TDriveType(GetDriveType(DriveNum));
  981.   if (Result = dtFixed) or (Result = dtNetwork) then
  982.   begin
  983.     if IsCDROM(DriveNum) then Result := dtCDROM
  984.     else if (Result = dtFixed) then
  985.     begin
  986.         { do not check for RAMDrive under Windows NT }
  987.       if ((GetWinFlags and $4000) = 0) and IsRAMDrive(DriveNum) then
  988.         Result := dtRAM;
  989.     end;
  990.   end;
  991. end;*)
  992.  
  993. begin
  994.   { Set the button colors to an aquamarine color scheme for drives }
  995.   ButtonColor := clTeal;
  996.   ButtonHLColor := clAqua;
  997.   ButtonSColor := clNavy;
  998.   TextColor := clblack;
  999.   { Set initial variables before looping for all drives }
  1000.   finished := false;
  1001.   DriveNum := 0;
  1002.   while not finished do
  1003.   begin
  1004.     { Start with no drive found }
  1005.     IconType := 0;
  1006.     (*=============REMOVED DUE TO WINDOWS 95=========
  1007.     { Call the Borland method to get the drive info }
  1008.     DriveType := FindDriveType(DriveNum);
  1009.     ===============END WINDOWS 95 REMOVAL==========*)
  1010.     { Set its letter and make it uppercase }
  1011.     DriveChar := Chr(DriveNum + ord('a'));
  1012.     DriveChar := Upcase(DriveChar);
  1013.     StrPCopy( DrivePC , DriveChar + ':\' );
  1014.     {*&&&&&&&&&&&&&&&  WIN 95 CALL  &&&&&&&&&&&&&&&&&&&*}
  1015.     DriveType := TDriveType(GetDriveType( DrivePC ));
  1016.     { Assign an icon based on the drive type; if no drive exists type is nil }
  1017.     case DriveType of
  1018.       dtFloppy  : IconType := 1;
  1019.       dtFixed   : IconType := 2;
  1020.       dtNetwork : IconType := 3;
  1021.       dtCDROM   : IconType := 4;
  1022.       dtRAM     : IconType := 5;
  1023.     end;
  1024.     { Set to check next drive letter }
  1025.     DriveNum := DriveNum + 1;
  1026.     { But if no match then out of drives so set exit flag }
  1027.     if IconType = 0 then finished := true;
  1028.     { If drive was valid then set up the new FileIconPanel on the imported }
  1029.     { Scrollbox                                                            }
  1030.     if not finished then
  1031.     begin
  1032.       { Create the FileIconPanel and set its parent for memory mgmt and display}
  1033.       TheFIP := TFileIconPanel.Create( Self );
  1034.       TheFIP.Parent := Self;
  1035.       { Call its initialize method with imported position values and the   }
  1036.       { preset color scheme, a drive caption, and a minimum font. Note the }
  1037.       { setting of the ExtraData field to non-zero; this signals a drive   }
  1038.       { rather than a file being sent in.                                  }
  1039.       TheFIP.Initialize((( XCounter - 1 ) * TheIconSpacing ),
  1040.        (( YCounter - 1  ) * TheIconSpacing ) , TheIconSize , TheIconSize , 3 ,
  1041.         7 , ButtonColor, ButtonHLColor,
  1042.        ButtonSColor , TextColor , 'DRIVE ' + DriveChar + ':' , 'MS Serif' , [] ,
  1043.        IconType );
  1044.       { Increment the column counter; if it exceeds max move to new row      }
  1045.       { Note that these are 'var' parameters and will export final position. }
  1046.       XCounter := XCounter + 1;
  1047.       if XCounter > MaxIconsInARow then
  1048.       begin
  1049.         XCounter := 1;
  1050.         YCounter := YCounter + 1;
  1051.       end;
  1052.     end;
  1053.   end;
  1054. end;
  1055.  
  1056. { This procedure assigns colors to FIP's based on file attributes }
  1057. procedure TFileIconPanelScrollBox.GetColorsForFileIcon( TheFile : String;
  1058.            var BC , HC , SC , TC : TColor );
  1059. var AmADir      ,             { Booleans hold file attribs }
  1060.     AmAnArchive ,
  1061.     AmAVolumeId ,
  1062.     AmHidden    ,
  1063.     AmReadOnly  ,
  1064.     AmSystem      : Boolean;
  1065. begin
  1066.   { Make the call to internal fileworkbench to set attributes }
  1067.   TheFWB.GetFileAttributes( TheFile , AmADir , AmAnArchive , AmAVolumeId ,
  1068.    AmHidden , AmReadOnly , AmSystem );
  1069.   { Volume ID has no subtypes }
  1070.   if AmAVolumeID then
  1071.   begin
  1072.     BC := clOlive;
  1073.     HC := clYellow;
  1074.     SC := clBlack;
  1075.     TC := clWhite;
  1076.     exit;
  1077.   end;
  1078.   { Check all directory combinations }
  1079.   if AmADir then
  1080.   begin
  1081.     BC := clNavy;
  1082.     HC := clBlue;
  1083.     SC := clBlack;
  1084.     TC := clWhite;
  1085.     if AmHidden then
  1086.     begin
  1087.       if AmReadOnly then
  1088.       begin
  1089.         if AmSystem then
  1090.         begin { One HECK of a file! }
  1091.           BC := clBlack;
  1092.           HC := clSilver;
  1093.           SC := clGray;
  1094.           TC := clWhite;
  1095.         end
  1096.         else
  1097.         begin { Dir,RO,Hid }
  1098.           BC := clMaroon;
  1099.           HC := clFuchsia;
  1100.           SC := clGreen;
  1101.           TC := clWhite;
  1102.         end;
  1103.       end
  1104.       else
  1105.       begin { Dir,Hid }
  1106.         BC := clPurple;
  1107.         HC := clFuchsia;
  1108.         SC := clBlack;
  1109.         TC := clWhite;
  1110.       end;
  1111.     end
  1112.     else
  1113.     begin
  1114.       if AmReadOnly then
  1115.       begin
  1116.         if AmSystem then
  1117.         begin { Dir,RO,Sys }
  1118.           BC := clMaroon;
  1119.           HC := clLime;
  1120.           SC := clGreen;
  1121.           TC := clWhite;
  1122.         end
  1123.         else
  1124.         begin { Dir,RO }
  1125.           BC := clGreen;
  1126.           HC := clLime;
  1127.           SC := clBlack;
  1128.           TC := clWhite;
  1129.         end;
  1130.       end
  1131.       else
  1132.       begin
  1133.         if AmSystem then
  1134.         begin { Dir,Sys }
  1135.           BC := clMaroon;
  1136.           HC := clRed;
  1137.           SC := clBlack;
  1138.           TC := clWhite;
  1139.         end;
  1140.       end;
  1141.     end;
  1142.   end
  1143.   else { Archive Only; check all combinations }
  1144.   begin
  1145.     BC := clSilver;
  1146.     HC := clWhite;
  1147.     SC := clGray;
  1148.     TC := clBlack;
  1149.     if AmHidden then
  1150.     begin
  1151.       if AmReadOnly then
  1152.       begin
  1153.         if AmSystem then
  1154.         begin { Hid,RO,Sys }
  1155.           BC := clRed;
  1156.           HC := clLime;
  1157.           SC := clPurple;
  1158.           TC := clBlack;
  1159.         end
  1160.         else
  1161.         begin { RO,Hid }
  1162.           BC := clLime;
  1163.           HC := clFuchsia;
  1164.           SC := clMaroon;
  1165.           TC := clBlack;
  1166.         end;
  1167.       end
  1168.       else
  1169.       begin { Hid }
  1170.         BC := clFuchsia;
  1171.         HC := clWhite;
  1172.         SC := clPurple;
  1173.         TC := clBlack;
  1174.       end;
  1175.     end
  1176.     else
  1177.     begin
  1178.       if AmReadOnly then
  1179.       begin
  1180.         if AmSystem then
  1181.         begin { RO,Sys }
  1182.           BC := clRed;
  1183.           HC := clLime;
  1184.           SC := clMaroon;
  1185.           TC := clBlack;
  1186.         end
  1187.         else
  1188.         begin { RO }
  1189.           BC := clLime;
  1190.           HC := clWhite;
  1191.           SC := clGreen;
  1192.           TC := clBlack;
  1193.         end;
  1194.       end
  1195.       else
  1196.       begin
  1197.         if AmSystem then
  1198.         begin { System }
  1199.           BC := clRed;
  1200.           HC := clWhite;
  1201.           SC := clMaroon;
  1202.           TC := clBlack;
  1203.         end;
  1204.       end;
  1205.     end;
  1206.   end;
  1207. end;
  1208.  
  1209. { This procedure gets all icons for an given directory, including drives and }
  1210. { standard subdirectories. It does not get special combinations or h/ro/sys  }
  1211. procedure TFileIconPanelScrollbox.GetIconsForEntireDirectory(
  1212.             TargetPath  : String );
  1213. var Finished        : Boolean;         { Loop flag              }
  1214.     TheSR           : TSearchRec;      { Searchrecord for FF/FN }
  1215.     TheResult       : Integer;         { return variable        }
  1216.     TempPath        : String;          { path for FF/FN         }
  1217.     TheFIP          : TFileIconPanel;  { generic FIP holder     }
  1218.     RowCounter    ,                    { position in row of FIP }
  1219.     ColumnCounter   : Integer;         { position in col of FIP }
  1220.     ButtonColor   ,                    { main panel color       }
  1221.     ButtonHLColor ,                    { bright panel color     }
  1222.     ButtonSColor  ,                    { dark panel color       }
  1223.     Textcolor       : TColor;          { label text color       }
  1224.     IsADir ,                           { Variable for file attr }
  1225.     IsAnArchive ,
  1226.     IsAVolumeID,
  1227.     IsAReadOnlyFile,
  1228.     IsAHiddenFile ,
  1229.     IsASystemFile     : Boolean;
  1230.     MaxTextLength     : Integer;       { Used to safely set size}
  1231. begin
  1232.   { hide during refresh }
  1233.   Visible := false;
  1234.   { Delete the current set, if any }
  1235.   ClearTheFIPs;
  1236.   { Get the icon sizes }
  1237.   TheFIP := TFileIconPanel.Create( Self );
  1238.   TheFIP.Parent := Self;
  1239.   TheFIP.FTheLabel.Canvas.Font.Name := 'MS Serif';
  1240.   TheFIP.FTheLabel.Canvas.Font.Size := 7;
  1241.   MaxTextLength := TheFIP.FTheLabel.Canvas.TextWidth( 'COMMAND.COM' );
  1242.   TheFIP.Free;
  1243.   TheIconSize := MaxTextLength + 13;
  1244.   TheIconSpacing := TheIconSize + 5;
  1245.   { Set up maximum icons per row based on screen size }
  1246.   MaxIconsInARow := ( Screen.Width div TheIconSpacing );
  1247.   { Set up the position counters }
  1248.   RowCounter := 1;
  1249.   ColumnCounter := 1;
  1250.   { Get the drives for the current machine }
  1251.   AddDriveIcons( ColumnCounter , RowCounter  );
  1252.   { Set up the initial variables }
  1253.   Finished := false;
  1254.   TempPath := TargetPath + '*.*';
  1255.   { Make the call to FindFirst set to get any file; will return '.' }
  1256.   { so discard it.                                                  }
  1257.   TheResult := FindFirst( TempPath , faAnyFile , TheSR );
  1258.   { loop through all files in the directory and look for directories }
  1259.   while not Finished do
  1260.   begin
  1261.     { Make call to FindNext, using only SearchRecord from FindFirst }
  1262.     TheResult := FindNext( TheSR );
  1263.     { A -1 result means no more files so exit }
  1264.     if TheResult <> 0 then finished := true else
  1265.     begin
  1266.       { Otherwise check for a directory attribute }
  1267.       if (( FileGetAttr( TargetPath + TheSR.Name ) and faDirectory ) =
  1268.        faDirectory ) then
  1269.       begin
  1270.         GetColorsForFileIcon( TargetPath + TheSR.Name , ButtonColor ,
  1271.          ButtonHLColor , ButtonSColor , TextColor );
  1272.         { If found create a new FileIconPanel on the imported scrollbox }
  1273.         { Note sending 0 ExtraData parameter to indicate file not drive }
  1274.         TheFIP := TFileIconPanel.Create( Self );
  1275.         TheFIP.Parent := Self;
  1276.         TheFIP.Initialize((( ColumnCounter - 1 ) * TheIconSpacing ),
  1277.          (( RowCounter - 1  ) * TheIconSpacing ) , TheIconSize, TheIconSize ,
  1278.           3 , 7 , ButtonColor, ButtonHLColor , ButtonSColor , TextColor ,
  1279.            TargetPath + TheSr.Name , 'MS Serif' , [] , 0 );
  1280.         { Increment column counter and move to new row if past limit }
  1281.         ColumnCounter := ColumnCounter + 1;
  1282.         if ColumnCounter > MaxIconsInARow then
  1283.         begin
  1284.           ColumnCounter := 1;
  1285.           RowCounter := RowCounter + 1;
  1286.         end;
  1287.       end;
  1288.     end;
  1289.   end;
  1290.   { Set up new initialization variables }
  1291.   Finished := false;
  1292.   TempPath := TargetPath + '*.*';
  1293.   { Make needed call to FindFirst and discard '.' }
  1294.   TheResult := FindFirst( TempPath , faAnyFile , TheSR );
  1295.   while not Finished do
  1296.   begin
  1297.     { Loop through file again, this time getting only archive files }
  1298.     TheResult := FindNext( TheSR );
  1299.     { Result of -1 indicates no more files }
  1300.     if TheResult <> 0 then Finished := true else
  1301.     begin
  1302.       { If faArchive file then add new FileIconPanel }
  1303.       TheFWB.GetFileAttributes(( Targetpath + TheSR.Name ) , IsADir ,
  1304.        IsAnArchive , IsAVolumeId , IsAHiddenFile , IsAReadOnlyFile ,
  1305.         IsASystemFile );
  1306.       if (( IsAnArchive ) and ( not IsADir )) then
  1307.       begin
  1308.         GetColorsForFileIcon( TargetPath + TheSR.Name , ButtonColor ,
  1309.          ButtonHLColor , ButtonSColor , TextColor );
  1310.         { Initialize new FileIconPanel and call initialize, sending 0 ED }
  1311.         TheFIP := TFileIconPanel.Create( Self );
  1312.         TheFIP.Parent := Self;
  1313.         TheFIP.Initialize((( ColumnCounter - 1 ) * TheIconSpacing ),
  1314.          (( RowCounter - 1  ) * TheIconSpacing ) , TheIconSize , TheIconSize ,
  1315.           3 , 7 , ButtonColor, ButtonHLColor , ButtonSColor , TextColor ,
  1316.            TargetPath + TheSr.Name , 'MS Serif' , [] , 0 );
  1317.         { Increment column counter and if needed row counter }
  1318.         ColumnCounter := ColumnCounter + 1;
  1319.         if ColumnCounter > MaxIconsInARow then
  1320.         begin
  1321.           ColumnCounter := 1;
  1322.           RowCounter := RowCounter + 1;
  1323.         end;
  1324.       end;
  1325.     end;
  1326.   end;
  1327.   { Reset to visible }
  1328.   Visible := true;
  1329. end;
  1330.  
  1331. { Update method for FIPscrollbox }
  1332. procedure TFileIconPanelScrollBox.Update;
  1333. begin
  1334.   IconsNeedRefreshing := true;
  1335.   { Force a repaint }
  1336.   InvalidateRect( TheStoredHandle , nil , true );
  1337. end;
  1338.  
  1339. { Create method for FIPScrollbox }
  1340. constructor TFileIconPanelScrollBox.Create( AOwner : TComponent );
  1341. begin
  1342.   inherited Create( AOwner );
  1343.   TheFWB := TFileWorkBench.Create( Self );
  1344. end;
  1345.  
  1346. { This function returns the next selected file's name }
  1347. function TFileIconPanelScrollBox.GetNextSelection( SourceDirectory : String;
  1348.                            var CurrentItem : Integer ) : String;
  1349. var TheResult    : String;      { Holds result of function }
  1350.     TheComponent : TComponent;  { Used for typecast        }
  1351.     finished     : boolean;     { Loop control variable    }
  1352.     TheComponentCount : Integer;
  1353. begin
  1354.   TheComponentCount := ComponentCount;
  1355.   { If past end of components exit with no result }
  1356.   if CurrentItem > TheComponentCount then TheResult := '' else
  1357.   begin
  1358.     { Set loop counter and run till find match or run out }
  1359.     finished := false;
  1360.     while not finished do
  1361.     begin
  1362.       { Pull component out of the list and check it }
  1363.       TheComponent := Components[ CurrentItem - 1 ];
  1364.       { Increment counter for later }
  1365.       CurrentItem := CurrentItem + 1;
  1366.       { Do the typecast with AS }
  1367.       with TheComponent as TFileIconPanel do
  1368.       begin
  1369.         { If its selected make sure OK }
  1370.         if Selected then
  1371.         begin
  1372.           { Don't accept backup for this level of operation }
  1373.           if FTheLabel.Caption <> '..' then
  1374.           begin
  1375.             { Otherwise return the name and abort the loop }
  1376.             TheResult := FTheName;
  1377.             finished := true;
  1378.           end;
  1379.         end
  1380.         else
  1381.         begin
  1382.           { Check to see if out of components }
  1383.           if CurrentItem > TheComponentCount then
  1384.           begin
  1385.             { If so signal error and abort }
  1386.             TheResult := '';
  1387.             finished := true;
  1388.           end;
  1389.         end;
  1390.       end;
  1391.     end;
  1392.   end;
  1393.   GetNextSelection := TheResult;
  1394. end;
  1395.  
  1396. end.
  1397.